home *** CD-ROM | disk | FTP | other *** search
/ Amiga Tools 2 / Amiga Tools 2.iso / tools / jade / lisp / buffers.jl < prev    next >
Lisp/Scheme  |  1995-03-09  |  19KB  |  527 lines
  1. ;;;; buffers.jl -- High-level buffer/file handling
  2. ;;;  Copyright (C) 1993, 1994 John Harper <jsh@ukc.ac.uk>
  3.  
  4. ;;; This file is part of Jade.
  5.  
  6. ;;; Jade is free software; you can redistribute it and/or modify it
  7. ;;; under the terms of the GNU General Public License as published by
  8. ;;; the Free Software Foundation; either version 2, or (at your option)
  9. ;;; any later version.
  10.  
  11. ;;; Jade is distributed in the hope that it will be useful, but
  12. ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14. ;;; GNU General Public License for more details.
  15.  
  16. ;;; You should have received a copy of the GNU General Public License
  17. ;;; along with Jade; see the file COPYING.  If not, write to
  18. ;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  19.  
  20. (defvar auto-save-p t
  21.   "When t files are auto-save'd regularly.")
  22. (defvar default-auto-save-interval 120
  23.   "The number of seconds between each auto-save.")
  24.  
  25. (defvar make-backup-files t
  26.   "When non-nil backups of files are made when they are saved.")
  27. (defvar backup-by-copying nil
  28.   "When non-nil all file backups are made by copying the file, not by
  29. renaming it.")
  30. (defvar else-backup-by-copying t
  31.   "Non-nil means make file backups by copying the file if it's not a good
  32. idea to rename it. If `backup-by-copying' is non-nil this variable has no
  33. effect.")
  34.  
  35. (defvar default-buffer (current-buffer)
  36.   "The `*jade*' buffer.")
  37.  
  38. ;; Initialise the first window's buffer-list
  39. (setq buffer-list (cons default-buffer nil))
  40.  
  41. (defvar standard-output default-buffer
  42.   "Stream that `prin?' writes its output to by default")
  43. (defvar standard-input default-buffer
  44.   "Stream that `read' takes it's input from by default")
  45.  
  46. (defvar buffer-file-modtime 0
  47.   "Holds the modification time of the file this buffer was loaded from")
  48. (make-variable-buffer-local 'buffer-file-modtime)
  49.  
  50. (defvar mildly-special-buffer nil
  51.   "When a buffer's `special' attribute is set kill-buffer will only kill
  52. it totally if this variable is non-nil.")
  53. (make-variable-buffer-local 'mildly-special-buffer)
  54.  
  55. (make-variable-buffer-local 'kill-buffer-hook)
  56.  
  57. (defvar enable-local-variables t
  58.   "Tells how to process local variable lists. t means process them
  59. silently, nil means ignore them, anything else means to query each
  60. variable being set.")
  61.  
  62. (defvar enable-local-eval 'maybe
  63.   "Tells how to process the `eval' local variable. Same options as
  64. with `enable-local-variables'.")
  65.  
  66. (defvar local-variable-lines 20
  67.   "This variable defines how many of the bottom-most lines in a file are
  68. searched for a `Local Variables:' section.")
  69.  
  70. (defun goto-buffer (buffer)
  71.   "Switch the current buffer to BUFFER which can either be a buffer-object
  72. or a string naming an existing buffer. The selected buffer is moved to
  73. the head of the buffer list. If BUFFER is a string and it doesn't name
  74. an existing buffer a new one will be created with that name."
  75.   (interactive "BSwitch to buffer")
  76.   (when (stringp buffer)
  77.     (setq buffer (open-buffer buffer)))
  78.   (unless (bufferp buffer)
  79.     (signal 'bad-arg (list buffer 1)))
  80.   (setq buffer-list (cons buffer (delq buffer buffer-list)))
  81.   (set-current-buffer buffer))
  82.  
  83. (defun open-file (name)
  84.   "If no buffer containing file NAME exits try to create one.
  85. After creating a new buffer (named after the file's (not path) name)
  86. it first call the hook `read-file-hook' with arguments `(buffer-file-name
  87. buffer)'.
  88. If this hook returns nil (ie, no members of the hook decided to read the
  89. file into memory) the file is read into the buffer verbatim.\n
  90. Once the file is in memory, through the hook or otherwise, this function
  91. then tries to initialise the correct editing mode for the file.\n
  92. `open-file' always returns the buffer holding the file, or nil if it
  93. doesn't exist."
  94.   (let
  95.       ((buf (get-file-buffer name)))
  96.     (unless buf
  97.       (when (setq buf (make-buffer (file-name-nondirectory name)))
  98.     (add-buffer buf buffer-list)
  99.     (with-buffer buf
  100.       (unless (eval-hook 'read-file-hook name buf)
  101.         (set-buffer-file-name buf name)
  102.         (if (file-exists-p name)
  103.         (progn
  104.           (read-buffer name)
  105.           (setq buffer-file-modtime (file-modtime name)))
  106.           (message "New file")))
  107.       (fix-local-variables)
  108.       (set-buffer-modified buf nil)
  109.       (when auto-save-p
  110.         (setq auto-save-interval default-auto-save-interval))
  111.       (setq last-save-time (current-time)
  112.         buffer-undo-list nil)
  113.       (when (auto-save-file-newer-p name)
  114.         (message "Warning: Auto-saved file is newer")
  115.         (beep))
  116.       (when (and (file-exists-p name) (not (file-writable-p name)))
  117.         (set-buffer-read-only buf t))
  118.       (eval-hook 'open-file-hook buf)
  119.       (init-mode buf))))
  120.     buf))
  121.  
  122. ;; Scans the end of a file for any local-variable definitions
  123. (defun fix-local-variables ()
  124.   (unless enable-local-variables
  125.     (return))
  126.   (let
  127.       ((pos (pos 0 (- (buffer-length) local-variable-lines))))
  128.     (when (< (pos-line pos) 0)
  129.       (set-pos-line pos 0))
  130.     (when (find-next-regexp "^(.*)Local Variables:(.*)$" pos)
  131.       (let
  132.       ((re (concat ?^
  133.                (regexp-quote (copy-area (match-start 1) (match-end 1)))
  134.                "([^:]+):(.*)"
  135.                (regexp-quote (copy-area (match-start 2) (match-end 2)))
  136.                ?$))
  137.        name value)
  138.     (setq pos (match-end))
  139.     (while (find-next-regexp re pos)
  140.       (setq pos (match-end)
  141.         name (copy-area (match-start 1) (match-end 1))
  142.         value (copy-area (match-start 2) (match-end 2)))
  143.       (cond
  144.        ((and (equal name "End") (equal value ""))
  145.         (return))
  146.        ((equal name "mode")
  147.         (when (or (eq enable-local-variables t)
  148.               (y-or-n-p (format nil "Use major mode %s?" value)))
  149.           (setq mode-name name)))
  150.        ((equal name "eval")
  151.         (when (and enable-local-eval
  152.                (or (eq enable-local-eval t)
  153.                (y-or-n-p (format nil "Eval `%s'?" value))))
  154.           (eval (read-from-string value))))
  155.        (t
  156.         (when (or (eq enable-local-variables t)
  157.               (y-or-n-p (format nil "Set %s to %s?" name value)))
  158.           (setq name (intern name))
  159.           (make-local-variable name)
  160.           (set name (read-from-string value))))))))))
  161.  
  162. (defun find-file (name)
  163.   "Sets the current buffer to that containing the file NAME, if NAME
  164. is unspecified it will be prompted for. If the file is not already in memory
  165. `open-file' will be used to load it."
  166.   (interactive "FFind file: ")
  167.   (goto-buffer (open-file name)))
  168.  
  169. (defun find-file-read-only (name)
  170.   "Similar to `find-file' except that the buffer is edited in read-only mode."
  171.   (interactive "FFind file read-only:")
  172.   (let
  173.       ((buf (open-file name)))
  174.     (when buf
  175.       (set-buffer-read-only buf t)
  176.       (goto-buffer buf))))
  177.  
  178. (defun find-alternate-file (name)
  179.   "If NAME is unspecified one will be prompted for. The current buffer is
  180. killed and one editing NAME is found."
  181.   (interactive "FFind alternate file:")
  182.   (kill-buffer (current-buffer))
  183.   (goto-buffer (open-file name)))
  184.  
  185. (defun backup-file (file-name)
  186.   "If necessary make a backup of FILE-NAME. The file called FILE-NAME may or
  187. may not exist after this function returns."
  188.   (when (and make-backup-files (file-regular-p name))
  189.     (let
  190.     ((backup-name (concat name ?~)))
  191.       (if backup-by-copying
  192.       (copy-file name backup-name)
  193.     (if (and (file-owner-p name)
  194.          (= (file-nlinks name) 1))
  195.         (progn
  196.           (when (file-exists-p backup-name)
  197.         (delete-file backup-name))
  198.           (rename-file name backup-name))
  199.       (when else-backup-by-copying
  200.         (copy-file name backup-name)))))))
  201.  
  202. (defun write-file (buffer &optional name)
  203.   "Writes the contents of BUFFER to the file NAME, or to the one
  204. that it is associated with."
  205.   (unless (stringp name)
  206.     (setq name (buffer-file-name buffer)))
  207.   (unless (eval-hook 'write-file-hook name buffer)
  208.     (let
  209.     ((modes (when (file-exists-p name) (file-modes name))))
  210.       (backup-file name)
  211.       (when (write-buffer name buffer)
  212.     (when modes
  213.       (set-file-modes name modes))
  214.     t))))
  215.  
  216. (defun save-file (&optional buffer &aux name)
  217.   "Saves the buffer BUFFER, or the current buffer, to the file that it is
  218. associated with, then sets the number of modifications made to this file
  219. to zero.
  220. Note: if no changes have been made to this buffer, it won't be saved."
  221.   (interactive)
  222.   (unless (bufferp buffer)
  223.     (setq buffer (current-buffer)))
  224.   (with-buffer buffer
  225.     (if (not (buffer-modified-p))
  226.     (message "No changes need to be saved!")
  227.       (let
  228.       ((name (buffer-file-name)))
  229.     (when (and
  230.            (> (file-modtime name) buffer-file-modtime)
  231.            (not (yes-or-no-p "File on disk has changed since it was loaded, save anyway")))
  232.       (return nil))
  233.     (when (write-file buffer)
  234.       (set-buffer-modified buffer nil)
  235.       (setq last-save-time (current-time)
  236.         last-save-changes (buffer-changes)
  237.         last-user-save-changes (buffer-changes)
  238.         buffer-file-modtime (file-modtime name))
  239.       (delete-auto-save-file)
  240.       (message (concat "Wrote file `" name ?\') t))))))
  241.  
  242. (defun save-file-as (name &optional buffer)
  243.   "Saves the buffer BUFFER, or the current one, to the file NAME,
  244. resetting the name of the buffer and the file that it is associated with
  245. to reflect NAME. Also sets the modification count to zero."
  246.   (interactive "FWrite file:")
  247.   (unless (bufferp buffer)
  248.     (setq buffer (current-buffer)))
  249.   (with-buffer buffer
  250.     (set-buffer-file-name buffer name)
  251.     (set-buffer-name buffer (file-name-nondirectory name))
  252.     (when (write-file buffer)
  253.       (set-buffer-modified buffer nil)
  254.       (setq last-save-time (current-time)
  255.         last-save-changes (buffer-changes)
  256.         last-user-save-changes (buffer-changes)
  257.         buffer-file-modtime (file-modtime name))
  258.       (delete-auto-save-file)
  259.       (format t "Saved file `%s'." name))))
  260.  
  261. (defun insert-file (name &optional buffer)
  262.   "Inserts the file NAME into the buffer BUFFER (or the current one) before
  263. the cursor position."
  264.   (interactive "FInsert file:")
  265.   (unless (bufferp buffer)
  266.     (setq buffer (current-buffer)))
  267.   (with-buffer buffer
  268.     (unless (eval-hook 'insert-file-hook name)
  269.       (insert (read-file name)))))
  270.  
  271. (defun open-buffer (name)
  272.   "If no buffer called NAME exists, creates one and adds it to the main
  273. buffer-list. Always returns the buffer."
  274.   (let
  275.       ((buf (get-buffer name)))
  276.     (unless buf
  277.       (when (setq buf (make-buffer name))
  278.     (add-buffer buf)))
  279.     buf))
  280.  
  281. (defun kill-buffer (buffer)
  282.   "Destroys BUFFER (can be an actual buffer or name of a buffer), first
  283. checks whether or not we're allowed to with the function `check-changes'.
  284.   If it can be deleted, all windows displaying this buffer are switched
  285. to the buffer at the head of the buffer-list, and BUFFER is removed
  286. from the buffer-list (if it was in it)."
  287.   (interactive "bBuffer to kill:")
  288.   (cond
  289.    ((bufferp buffer))
  290.    ((stringp buffer)
  291.     (setq buffer (get-buffer buffer))))
  292.   (when (and buffer (check-changes buffer))
  293.     (eval-hook 'kill-buffer-hook buffer)
  294.     (unless (and (buffer-special-p buffer)
  295.          (null (with-buffer buffer mildly-special-buffer)))
  296.       (kill-mode buffer)
  297.       (destroy-buffer buffer))
  298.     (remove-buffer buffer)
  299.     t))
  300.  
  301. (defun bury-buffer (&optional buffer all-windows)
  302.   "Puts BUFFER (or the currently displayed buffer) at the end of the current
  303. window's buffer-list then switch to the buffer at the head of the list.
  304. If ALL-WINDOWS is non-nil this is done in all windows (the same buffer
  305. will be buried in each window though)."
  306.   (interactive)
  307.   (unless buffer
  308.     (setq buffer (current-buffer)))
  309.   (let
  310.       ((list (if all-windows
  311.          window-list
  312.            (cons (current-window) nil))))
  313.     (while list
  314.       (with-window (car list)
  315.     (let
  316.         ((old-list (copy-sequence buffer-list)))
  317.       (setq buffer-list (nconc (delq buffer buffer-list)
  318.                    (cons buffer nil)))
  319.       (set-current-buffer (car buffer-list))
  320.       ;; It seems that buffer-list sometimes?
  321.       (when (/= (length buffer-list) (length old-list))
  322.         (error "buffer-list changed length!"))))
  323.       (setq list (cdr list)))))
  324.  
  325. (defun switch-to-buffer ()
  326.   "Prompt the user for the name of a buffer, then display it."
  327.   (interactive)
  328.   (let*
  329.       ((default (or (nth 1 buffer-list) (current-buffer)))
  330.        (buffer (prompt-for-buffer (concat "Switch to buffer (default: "
  331.                       (buffer-name default)
  332.                       "):")
  333.                   nil
  334.                   default)))
  335.     (goto-buffer buffer)))
  336.  
  337. (defun rotate-buffers-forward ()
  338.   "Moves the buffer at the head of the buffer-list to be last in the list, the
  339. new head of the buffer-list is displayed in the current window."
  340.   (interactive)
  341.   (let
  342.       ((head (car buffer-list))
  343.     (end (nthcdr (1- (length buffer-list)) buffer-list)))
  344.     (rplacd end (cons head nil))
  345.     (setq buffer-list (cdr buffer-list))
  346.     (set-current-buffer (car buffer-list))))
  347.  
  348. ;(defun rotate-buffers-backward (&aux end)
  349. ;  "(rotate-buffers-backward)
  350. ;Moves the buffer at the end of the buffer-list to be first in the list, the
  351. ;new head of the buffer-list is displayed in the current window."
  352. ;  (setq
  353. ;    end (nthcdr (- 2 (length buffer-list)) buffer-list)
  354. ;    buffer-list (cons (last buffer-list) buffer-list))
  355. ;  (rplacd end nil)
  356. ;  (set-current-buffer (car buffer-list)))
  357.  
  358. (defun check-changes (&optional buffer)
  359.   "Returns t if it is ok to kill BUFFER, or the current buffer. If unsaved
  360. changes have been made to it the user is asked whether (s)he minds losing
  361. them."
  362.   (or (not (buffer-modified-p buffer))
  363.       (yes-or-no-p (format nil "OK to lose change(s) to buffer `%s'"
  364.                (file-name-nondirectory (buffer-name buffer))))))
  365.  
  366. (defun goto-mark (mark)
  367.   "Switches (if necessary) to the buffer containing MARK at the position
  368. of the mark. If the file containing MARK is not in memory then we
  369. attempt to load it with `open-file'."
  370.   (when (markp mark)
  371.     (let
  372.     ((file (mark-file mark))
  373.      (pos (mark-pos mark)))
  374.       (when (stringp file)
  375.     (setq file (open-file file)))
  376.       (set-auto-mark)
  377.       (goto-buffer file)
  378.       (goto-char pos))))
  379.  
  380. (defun set-auto-mark ()
  381.   "Sets the mark `auto-mark' to the current position (buffer & cursor-pos)."
  382.   (interactive)
  383.   (set-mark auto-mark (cursor-pos) (current-buffer))
  384.   (message "Set auto-mark."))
  385.  
  386. (defun swap-cursor-and-auto-mark ()
  387.   "Sets the `auto-mark' to the current position and then sets the current
  388. position (buffer and cursor-pos) to the old value of `auto-mark'."
  389.   (interactive)
  390.   (let
  391.       ((a-m-file (mark-file auto-mark))
  392.        (a-m-pos (copy-pos (mark-pos auto-mark))))
  393.     (set-auto-mark)
  394.     (when (stringp a-m-file)
  395.       (setq a-m-file (open-file a-m-file)))
  396.     (set-current-buffer a-m-file)
  397.     (goto-char a-m-pos)))
  398.  
  399. (defun split-line-indent ()
  400.   "Inserts a newline at the cursor position and then indents the new line
  401. created to the indentation of the one above it."
  402.   (interactive)
  403.   (let
  404.       ((old-indent-pos (next-line 1 (indent-pos))))
  405.     (split-line)
  406.     (if (empty-line-p)
  407.     (goto-glyph old-indent-pos)
  408.       (set-indent-pos old-indent-pos))))
  409.  
  410. (defun make-auto-save-name (name)
  411.   "Returns a string naming the file used to hold the auto-save'd file for
  412. file NAME."
  413.   (concat (file-name-directory name) ?# (file-name-nondirectory name) ?#))
  414.  
  415. (defun auto-save-function (buffer)
  416.   "Automatically called when BUFFER is due to be automatically saved.
  417. This function calls the hook `auto-save-hook', if this returns nil it then
  418. saves it to the file specified by `make-auto-save-name' appiled to the
  419. name of the file stored in BUFFER."
  420.   (format t "Auto-saving `%s'..." (buffer-name buffer))
  421.   (refresh-all)
  422.   (flush-output)
  423.   (with-buffer buffer
  424.     (if (or (eval-hook 'auto-save-hook buffer)
  425.         (write-buffer (make-auto-save-name (buffer-file-name))))
  426.     (format t "done.")
  427.       (error "Can't auto-save" buffer)
  428.       nil)))
  429.  
  430. (defun delete-auto-save-file (&optional buffer)
  431.   "Deletes the file used to store the auto-save'd copy of the file stored in
  432. BUFFER, if such a file exists."
  433.   (interactive)
  434.   (let
  435.       ((a-name (make-auto-save-name (buffer-file-name buffer))))
  436.     (when (file-exists-p a-name)
  437.       (delete-file a-name))))
  438.  
  439. (defun auto-save-file-newer-p (name)
  440.   "Returns t if there exists an automatically saved copy of file NAME which
  441. is newer than NAME."
  442.   (let
  443.       ((recover-name (make-auto-save-name name)))
  444.     (> (file-modtime recover-name) (file-modtime name))))
  445.  
  446. (defun recover-file (&optional buffer)
  447.   "Loads the auto-saved copy of the file stored in BUFFER into BUFFER
  448. overwriting its current contents (if any changes are to be lost the user
  449. will have to agree to this)."
  450.   (interactive)
  451.   (let
  452.       ((recover-name (make-auto-save-name (buffer-file-name buffer))))
  453.     (unless buffer
  454.       (setq buffer (current-buffer)))
  455.     (when (and (file-exists-p recover-name) (check-changes buffer))
  456.       (with-buffer buffer
  457.     (read-buffer recover-name)
  458.     (set-buffer-modified buffer t)
  459.     (setq last-save-time (current-time))
  460.     (message (concat "Using " recover-name " as "
  461.              (buffer-file-name buffer)))))
  462.     buffer))
  463.  
  464. (defun revert-buffer (&optional buffer)
  465.   "Restores the contents of BUFFER (or current buffer) to the contents of the
  466. file it was loaded from."
  467.   (interactive)
  468.   (unless buffer
  469.     (setq buffer (current-buffer)))
  470.   (if (and (auto-save-file-newer-p (buffer-file-name buffer))
  471.        (yes-or-no-p "auto-saved file is newer; recover-file instead?"))
  472.       (recover-file buffer)
  473.     (when (check-changes buffer)
  474.       (with-buffer buffer
  475.     (unless (eval-hook 'read-file-hook (buffer-file-name buffer) buffer)
  476.       (read-buffer (buffer-file-name buffer)))
  477.     (set-buffer-modified buffer nil)
  478.     (setq last-save-time (current-time))))))
  479.  
  480. (defun goto-line (line)
  481.   "Goto line number LINE. LINE counts from 1."
  482.   (interactive "NLine: ")
  483.   (set-auto-mark)
  484.   (goto-char (pos nil (1- line))))
  485.  
  486. (defun file-newer-than-file-p (file1 file2)
  487.   "Returns t of FILE1 was modified more recently than FILE2."
  488.   (> (file-modtime file1) (file-modtime file2)))
  489.  
  490. (defun save-some-buffers ()
  491.   "Asks whether or not to save any modified buffers, returns t if no modified
  492. buffers are left."
  493.   (interactive)
  494.   (let
  495.       ((bufs buffer-list)
  496.        buf
  497.        (unsaved-files-p nil))
  498.     (while (consp bufs)
  499.       (setq buf (car bufs))
  500.       (when (and (buffer-modified-p buf) (not (buffer-special-p buf)))
  501.     (if (y-or-n-p (concat "Save buffer " (buffer-name buf)))
  502.         (unless (save-file buf)
  503.           (setq unsaved-files-p t))
  504.       (setq unsaved-files-p t)))
  505.       (setq bufs (cdr bufs)))
  506.     (not unsaved-files-p)))
  507.  
  508. (defun save-and-quit ()
  509.   "Calls `save-some-buffers' and quits (after asking whether it's ok to lose
  510. any unsaved buffers)."
  511.   (interactive)
  512.   (when (or (save-some-buffers)
  513.         (yes-or-no-p "Unsaved buffers exist; quit anyway?"))
  514.     (throw 'quit 0)))
  515.  
  516. (defun auto-save-mode (&optional disable)
  517.   "When this mode is enabled files are autosaved regularly if
  518. they've been modified."
  519.   (interactive "P")
  520.   (if (or (/= auto-save-interval 0)
  521.       disable)
  522.       (progn
  523.     (setq auto-save-interval 0)
  524.     (message "Auto-save is now disabled in this buffer."))
  525.     (setq auto-save-interval default-auto-save-interval)
  526.     (message "Auto-save is now enabled for this buffer.")))
  527.